(* This file is part of IsoType.
 *
 * IsoType is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * IsoType is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with IsoType.  If not, see <http://www.gnu.org/licenses/>.
 *)

let read_interface flags file_name =
  let eq = Equivalence.iso flags in
  let chin = open_in file_name in
  let lexbuf = Lexing.from_channel chin in
  let mdule = Parser.main Lexer.token lexbuf in
    close_in chin;
    if Flags.debug flags then
      begin
	print_endline "======================";
	print_endline "=== BEFORE MAPPING ===";
	print_endline "======================";
	List.iter Pp.pp_entity mdule
      end;
    let (types_tbl, values_tbl) = Resolver.resolve mdule flags in
      if Flags.debug flags then
	begin
	  print_endline "=====================";
	  print_endline "=== AFTER MAPPING ===";
	  print_endline "=====================";
	  Pp.pp_types types_tbl;
	  Pp.pp_values values_tbl
	end;
      if Flags.verbose flags then
	begin
	  prerr_endline (Printf.sprintf "Loading %s..." file_name);
	  flush stderr
	end;
      let vts =
	let ntyps = Hashtbl.fold (fun name typ l -> (name, typ) :: l) values_tbl [] in
	  List.combine
	    (List.map fst ntyps)
	    (List.map (Type.translate flags types_tbl) (List.map snd ntyps))
      in
      let tvs = ListAux.parts (fun (_, typ) (_, typ') -> eq typ typ') vts in
	List.map
	  (function
	       [] -> assert false (* IMPOSSIBLE *)
	     | (((_, typ) :: _) as l) -> (typ, List.map fst l)
	  )
	  tvs

let compute_distance flags if1 if2 =
  let cardinality l = List.length l in
  let eq = Equivalence.iso flags in
  let dist = Distance.distance_function (Flags.distance flags) in
  let typs = ListAux.union_eq eq (List.map fst if1) (List.map fst if2) in
  let vectors = List.map
    (fun typ ->
       let xs = ListAux.assoc_eq_default [] eq typ if1
       and ys = ListAux.assoc_eq_default [] eq typ if2 in
       let cx = cardinality xs
       and cy = cardinality ys in
	 if Flags.show_differences flags && cx <> cy then
	   begin
	     let map_qnames xs =
	       String.concat ", " (List.sort Pervasives.compare (List.map Pp.string_of_qname xs))
	     in
	       Printf.printf "TYPE %s\n" (Type.string_of_type typ);
	       Printf.printf " %d> %s\n" cx (map_qnames xs);
	       Printf.printf " %d> %s\n" cy (map_qnames ys)
	   end;
	 float_of_int cx, float_of_int cy
    )
    typs
  in
  let ps, qs = List.split vectors in
    dist ps qs
    
let _ = 
  let names, flags = Flags.parse_arguments () in
  let names' = Array.map (fun name -> "../Tests/" ^ name ^ ".if") names in
  let ifaces = Array.map (read_interface flags) names' in
  let n = ref 0 in
  let start_time = Sys.time () in
  let m = (Array.length names * (Array.length names - 1)) / 2 in
  let iterate i0 =
    for i = i0 + 1 to Array.length names - 1 do
      let t0 = Sys.time () in
      let dist = compute_distance flags ifaces.(i0) ifaces.(i) in
      let t1 = Sys.time () in
      let total_time = t1 -. start_time in
	if Flags.verbose flags then
	  begin
	    let avg_time = total_time /. float_of_int !n in
	      incr n;
	      prerr_endline (Printf.sprintf "%3s %3s : %3.3f     (%2.3fsec AT: %2.3fsec RC: %4d ERT: %4.3fsec)"
			       names.(i0) names.(i) dist
			       (t1 -. t0)
			       avg_time
			       (m - !n)
			       ((total_time *. float_of_int (m - !n)) /. float_of_int !n)
			    );
	      flush stderr
	  end;
	Printf.printf "(%s,%s) %f\n" names.(i0) names.(i) dist;
	flush stdout
    done 	  
  in
    if Flags.focus_on flags then
      iterate 0
    else
      for i = 0 to Array.length names - 1 do
	iterate i
      done
